perm filename PRETTY.VLI[1,3] blob
sn#379409 filedate 1978-09-11 generic text, type C, neo UTF8
COMMENT ā VALID 00013 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 P R E T T Y C R O S S - R E F E R E N C E
C00004 00003 3 %TAB ADDN FLATSIZE SARENTRE SORTL
C00007 00004 4 %EOL %TERPRI %PC XPRDOT XSUIV
C00009 00005 5 %PPTC %P1 %PP
C00011 00006 6 XPRTTY XPRTTY1 XPRTTY2
C00013 00007 7 SUPERP
C00016 00008 8 SUPERP (suite)
C00021 00009 9 PRETTYNIT PRETTYFIN PRETTYP PRETTY
C00024 00010 10 PRETTYFILE
C00028 00011 11 PRETTYF PRETTYSIZE PRETTYEND
C00030 00012 12 CROSSPRINT
C00032 00013 13 CROSS CROSSFILE CROSSF
C00034 ENDMK
Cā;
; P R E T T Y C R O S S - R E F E R E N C E ;
; ;
; Editeur / Indexeur VLISP 10 . 3 ;
;----------------------------------------------------------;
; Jerome CHAILLOUX ;
; ;
; Universite de Paris VIII - Vincennes ;
; Route de la Tourelle 75012 Paris ;
; Tel : 374 12 50 poste 299 ;
; ;
; I.R.C.A.M. ;
; 31 Rue St Merri 75004 Paris ;
; Tel : 277 12 33 poste 48-48 ;
;----------------------------------------------------------;
; 3 %TAB ADDN FLATSIZE SARENTRE SORTL ;
(MAPC '(/( /) /. / /') (LAMBDA (X) (SET X X)))
(OR (BOUNDP '?index) (SETQ ?index ()))))
(DE %TAB (col) (STATUS 7 (PLUS col (STATUS 7))))
(DE ADDN (X) (AND (LT %T (SETQ %N X)) (EXIT)) T)
(DE FLATSIZE (%L %N)
; calcule la taille de l'expression %L ;
(COND
((ATOM %L) (PLENGTH %L))
((AND (EQ (CAR %L) QUOTE) (NULL (CDDR %L)))
(ADD1 (FLATSIZE (CADR %L))))
((EQ (CAR %L) 'LIST) (FLATSIZE (CDR %L)))
((EQ (CAR %L) 'COMMENT) (PLUS 2 (LENGTH (CDR %L))))
((ADDN (PLUS 2 (FLATSIZE (NEXTL %L))))
(WHILE (LISTP %L)
(ADDN (PLUS %N (ADD1 (FLATSIZE (NEXTL %L))))))
(AND %L (ADDN (PLUS %N 3 (FLATSIZE %L))))
%N)))
(DE SARENTRE (%E %T)
; predicat qui teste si %E rentre dans la ligne courante ;
(ESCAPE EXIT
(SETQ %T (DIFFER (STATUS 9) (STATUS 8) 5))
(GT %T (FLATSIZE %E))))
(DE SORTL (L ;; RESL N Q L2 LL)
; trie la liste d'atomes L , une version de QUICKSORT ;
; Patrick GREU. Aout 78 ;
; Pour l'OBLIST, le vieux SORTL prenait 102640 ms ;
; le nouvo SORTL prends 4200 ms ;
; FFFFFFFFFFRRRRRRRRRRRRR........ ;
(IF (NULL L) ()
(SETQ RESL [NIL])
(PUSH (LENGTH L) L)
(LET ((L1)) ; L1 <doit> etre locale, voyez-vous pourquoi ? ;
(SETQ L1 (POP) N (POP))
(IF (EQN N 1) (LESCAPE L1))
(SETQ Q (LOGSHIFT N -1)) (PUSH Q L1)
(SETQ L1 (NTH Q L1))
(PUSH (PLUS (LOGAND N 1) Q) (CDR L1))
(RPLACD L1 NIL)
(SETQ L1 (SELF) L2 (SELF) LL (RPLACD RESL L1))
(WHILE L1
(IF (SORT (CAR L2) (CAR L1))
(SETQ N L1 L1 L2 L2 N N (RPLACD LL L1)))
(SETQ LL L1 L1 (CDR L1)))
(RPLACD LL L2) (CDR RESL))))
; 4 %EOL %TERPRI %PC XPRDOT XSUIV ;
(DE %EOL ()
; TESTE SI Y FO UN TERPRI ;
(IF (GT (STATUS 8) (STATUS 7))
(%TERPRI)
(STATUS 8 (STATUS 7))))
(DE %TERPRI (%N)
; effectue un TERPRI en numerotant les lignes ;
(TERPRI %N)
(IF ?index (PROGN (TTAB 0)
(PRIN1 (INCR #nbline))
(TTAB (STATUS 7)))))))
(DF %PC (%L)
; imprime un commentaire ;
(%TERPRI)
(PRINC PTVRG 1)
(EPROGN %L)
(SPACES 1)
(PRINC PTVRG 1)
(%TERPRI 2))
(DE %PRIN1 (%L)
; simule PRIN1 et fabrique l'index ;
(PRIN1 %L)
(IFN ?index (LESCAPE %L))
(IF (AND %L (LITATOM %L) (OR ?crossall (GT (LOC %L) (LOC 'STOP))))
(PUT %L (CONS #nbline (GET %L 'CROSS)) 'CROSS))
%L))))
(DE XPRDOT () (PRINC /.) (SPACES 1) (%PRIN1 %E))
(DE XSUIV ()
(AND
(ATOM %E)
(EXIT (PRINC /. 1) (SPACES 1) (%PRIN1 %E) (PRINC /) 1)))
(NEXTL %E))
; 5 %PPTC %P1 %PP ;
(DE %PPTC ()
; edite sur la meme ligne le commentaire (s'il existe) ;
; en tete de %E et met a jour %E ;
(IF (EQ (CAR %E) 'COMMENT)
(PROGN (%P1) (NEXTL %E))))
(DE %P1 ()
; imprime sur la meme ligne l'objet suivant de %E ;
(%PPTC)
(COND
((SARENTRE (CAR %E))
(SPACES 1)
(COND
((CAR %E) (SUPERP (NEXTL %E)))
((PRINC /( 1) (PRINC /) 1) (NEXTL %E))))
(T (%TAB 1)
(SPACES 1)
(%EOL)
(SUPERP (NEXTL %E))
(%TAB -1)))
(%PPTC))
(DE %PP (%E)
; imprime un : PROG DO LAP LOAD ;
(%TAB 7)
(MAPC %E
(LAMBDA (%E)
(COND
((ATOM %E)
(%TERPRI)
(STATUS 8 (DIFFER (STATUS 7) 7))
(%PRIN1 %E)
(%EOL))
((EQ (CAR %E) 'COMMENT)
(IF (SARENTRE %E) (SPACES 1) (%TERPRI))
(SUPERP %E))
(T (%EOL) (SUPERP %E)))))
(%TAB -7))
; 6 XPRTTY XPRTTY1 XPRTTY2 ;
(DE XPRTTY ()
; edite les differents elements de %E (normalement) ;
(COND
((SARENTRE %E) (WHILE %E (SPACES 1) (SUPERP (XSUIV %E))))
((SPACES 1)
(%TAB 3)
(MAPC %E (LAMBDA (%E) (%EOL) (SUPERP %E)))
(%TAB -3)))
(PRINC '/) 1))
(DE XPRTTY1 ()
; edite 1 element sur la meme ligne ;
; et le reste normalement ;
(%P1) (XPRTTY))
(DE XPRTTY2 ()
; edite des clauses de 'COND' ou de 'SELECT..' ;
(%TAB 3)
(MAPC %E
(LAMBDA (%E)
(%EOL)
(IF (EQ (CAR %E) 'COMMENT)
(LESCAPE (SUPERP %E))
(PRINC /( 1)
(%TAB 1)
(SUPERP (NEXTL %E))
(%TAB -1)
(XPRTTY))))
(%TAB -3)
(PRINC /) 1))
; 7 SUPERP ;
(DE SUPERP (%E ;; %L %F %T)
; edite %E ;
(IF (ATOM %E) (LESCAPE (%PRIN1 %E)))
; c'est donc une liste ;
; %F = le typ de la fonction a editer ;
(SETQ %F (OR (AND (LITATOM (CAR %E)) (GET (CAR %E) 'PRETTY))
(CAR %E)))
(ESCAPE EXIT
(COND
((AND (EQ %F QUOTE) (NULL (CDDR %E)))
(SETQ %E (CADR %E))
(AND (ATOM %E) (NOT (SARENTRE %E)) (%TERPRI))
(PRINC /')
(SUPERP %E))
((and (listp (car %e)) (eq (caar %e) lambda))
(setq %l (cadar %e) %t (cdr %e))
(superp (mcons 'let
(mapcar %l (lambda (x) [x (nextl %t)]))
(cDDar %e))))
((AND (EQ %F 'MCONS) (NULL (CDR (LAST %E))))
; (MCONS x1 ... xN) [ x1 ... xN-1 . xN] ;
(PRINC '/[)
(NEXTL %E)
(COND
((SARENTRE %E)
(WHILE (LISTP (CDR %E))
(SUPERP (NEXTL %E))
(SPACES 1)))
(T (%TAB 1)
(WHILE (LISTP (CDR %E))
(SUPERP (NEXTL %E))
(%TERPRI))
(%TAB -1)))
(PRINC /.) (PRINC / )
(SUPERP (CAR %E))
(PRINC '/]))
((AND (EQ %F 'CONS) (NULL (CDR (LAST %E))) (NULL (CDDDR %E)))
; (CONS x1 x2) [x1 . x2] ;
(SUPERP ['MCONS . (CDR %E)]))
((AND (EQ %F 'NCONS) (NULL (CDDR %E)))
; (NCONS x1) [x1] ;
(SUPERP ['LIST . (CDR %E)]))
((AND (EQ %F 'LIST) (NULL (CDR (LAST %E))))
; (LIST x1 ... xN) [x1 ... xN] ;
(PRINC '/[)
(NEXTL %E)
(COND
((SARENTRE %E)
(WHILE (LISTP %E)
(SUPERP (NEXTL %E))
(AND %E (SPACES 1))))
(T (%TAB 1)
(WHILE (LISTP %E)
(SUPERP (NEXTL %E))
(AND %E (%TERPRI)))
(%TAB -1)))
(AND %E (XPRDOT))
(PRINC '/]))
; 8 SUPERP (suite) ;
;;
((AND (EQ %F 'FUNCTION) (NULL (CDDR %E)))
(PRINC /()
(%PRIN1 (NEXTL %E))
(SPACES 1)
(SUPERP (CAR %E))
(PRINC /)))
((EQ %F 'COMMENT)
(AND (EQUAL (CDR %E) '(P A G E)) (EXIT (PAGE)))
(PRINC PTVRG)
(%TAB (SETQ %T (DIFFER (STATUS 8) (STATUS 7))))
(MAPC (CDR %E) 'PRINC)
(%TAB (MINUS %T))
(PRINC PTVRG))
((EVERY %E 'ATOM)
(PRINC /()
(%TAB (SETQ %T (DIFFER (STATUS 8) (STATUS 7))))
(WHILE (LISTP %E)
(OR (SARENTRE (CAR %E)) (%TERPRI))
(%PRIN1 (NEXTL %E))
(AND %E (SPACES 1)))
(AND %E (XPRDOT))
(PRINC /))
(%TAB (MINUS %T)))
((PRINC /()
(WHILE %E
(SETQ %L (XSUIV %E))
(COND
((NULL %E))
((OR
(MEMQ %L %S)
(MEMQ %F
'(OR AND LIST MCONS NCONC1 APPEND1 PLUS DIFFER
TIMES QUO MIN MAX PUSH EXPLODE GENSYM
LESCAPE PROGN PROG1 PROG2 LET)))
(%PRIN1 %L)
(EXIT (XPRTTY)))
((MEMQ %F '(SET SETQ SETQQ))
(%PRIN1 %L)
(COND
((SARENTRE %E)
(WHILE %E
(SPACES 1)
(SUPERP (NEXTL %E))))
((%TAB 3)
(WHILE %E
(%TERPRI)
(SUPERP (NEXTL %E))
(IF %E
(%P1)
(EXIT (PRINC /)) (%TAB -3))))
(%TAB -3)))
(EXIT (PRINC '/))))
((EQ %L 'ESCAPE)
(%PRIN1 %L)
(SETQ %S (CONS (CAR %E) %S))
(EXIT (XPRTTY1) (NEXTL %S)))
((MEMQ %F '(DE DF DM DMI DMO DMC DG MACLAP MACMP DGEN))
; tous les types de definitions standards ;
(%PRIN1 %L)
(SPACES 1)
(IF (LITATOM (CAR %E))
; forme normale des DEFs ;
(PROGN (SUPERP (NEXTL %E))
(EXIT (XPRTTY1)))
; call-forme des DEFs ;
(SUPERP (NEXTL %E))
(EXIT (XPRTTY))))
((MEMQ %F
'(LAMBDA WHILE UNTIL STATUS BOOLE PUT IFN GAMMA
IF EVERY SOME REPEAT ORF ANDF MAP MAPC MAPS
MAPLIST MAPSUB MAPT MAPCT MAPST POUR))
(%PRIN1 %L)
(EXIT (XPRTTY1)))
((EQ %F 'PROG)
(%PRIN1 %L)
(SPACES 1)
(SUPERP (NEXTL %E))
(EXIT (%PP %E)))
((EQ %F 'LAP)
(%PRIN1 %L)
(OR (EQ (CAAR %E) QUOTE) (EXIT (XPRTTY)))
(SPACES 1)
(PRINC /')
(PRINC /()
(%PP (CADAR %E))
(NEXTL %E)
(EXIT (XPRTTY)))
((MEMQ %F '(SELECT SELECTQ))
(%PRIN1 %L)
(SPACES 1)
(%P1)
(EXIT (XPRTTY2)))
((EQ %F 'COND) (%PRIN1 %L) (EXIT (XPRTTY2))))
(%TAB 1)
(OR (SARENTRE %L) (%EOL))
(SUPERP %L)
(AND %E (SPACES 1))
(%TAB -1))
(PRINC '/))))))
; 9 PRETTYNIT PRETTYFIN PRETTYP PRETTY ;
(DE PRETTYNIT ()
; initialisation des STATUS avant edition ;
(PUSH (STATUS 7) (STATUS 9) (STATUS 0))
(STATUS 7 (IF ?index 6 1))
(STATUS 9 PRETTYSIZE)
(STATUS 2 19 25)
(STATUS 1 24 26))
(DE PRETTYFIN ()
; restauration des STATUS apres edition ;
(MAPC '(0 9 7) (LAMBDA (%X) (STATUS %X (POP))))
(TERPRI))
(DE PRETTYP (%E ;; %S)
; PRETTY-PRINT une S-expression ;
; %S est la table des ESCAPEs actifs ;
(PRETTYNIT)
(SUPERP %E)
(PRETTYFIN)
%E)
(DF PRETTY (%L ;; %X)
; PRETTY-PRINT des fonctions ;
(MAPC %L
(LAMBDA (%L)
(%TERPRI)
(COND
((SETQ %X (GETL %L '(EXPR FEXPR MACRO MACIN MACOUT
MACLAP !macmp !gen)))
; cas des fonctions normales ;
(PRETTYP (MCONS
(CASSQ (CAR %X)
'((EXPR . DE)(FEXPR . DF)(MACRO . DM)
(MACIN . DMI)(MACOUT . DMO)
(MACLAP . MACLAP)(!macmp . MACMP)
(!gen . DGEN)))
%L
(CDR (CADR %X)))))
((AND (EQ (PLENGTH %L) 1)
(SETQ %X (STATUS 18 %L)))
; cas des macros-caracteres ;
(PRETTYP (MCONS 'DMC %L (CDR %X))))
((BOUNDP %L)
; on essaie la C-val ;
(PRETTYP (CAR %L)))
(T ; on sait pas ce que c'est ;
(PRINT "PRETTY : C'est quoi au juste " %L)))
(%TERPRI)))))
; 10 PRETTYFILE ;
(DE PRETTYFILE (filout filin ?sw1 ;; %S lu lastprtcom)
; ?sw1 = T si on laisse les casses en l'etat ;
; %S est la liste des ESCAPEs actifs ;
; lastprtcom sert a controler l supression de lignes ;
; blanches entre 2 commantaires ;
(DE EOF ()
(REMPROP 'TOPLEVEL EXPR)
(REMPROP 'EOF EXPR)
(PRETTYFIN)
(IFN ?index ()
(STATUS 7 0)
(PAGE)
(CROSSPRINT))
(%PC (PRIN1 (IF (BOUNDP 'VERSION) VERSION (VERSION))
(DATE) (TIME) 'END 'OF 'FILE ': filin))
(STATUS 17 (ASCII 13) 0)
(STATUS 19 PTVRG)
(STATUS 19 (ASCII 12))
(STATUS 1 18 19)
(OUTPUT)
(INPUT)
(&EOF filout))
(DE TOPLEVEL ()
(SETQ lu (READ))
(COND
((ATOM lu) (PRINT lu))
((AND (EQ (CAR lu) 'POUR) (EQ (CADR lu) 'PRETTY))
(EPROGN (CDDR lu)))
((NEQ (CAR lu) 'COMMENT)
(AND lastprtcom (%TERPRI))
(IF (AND ?index
(MEMQ (CAR lu) '(DE DF DM DMI DMO DMC DA)))
(SETQ #nbfnt (CONS [ (CADR lu) (CAR lu) #nbline] #nbfnt)))
(SUPERP lu) (SETQ lastprt) (%TERPRI))
(T (SETQ lastprtcom T) (SUPERP lu)))
(%TERPRI))
(STATUS 17 (ASCII 13) 1)
(STATUS 18 (ASCII 12) (LAMBDA () ['COMMENT 'P 'A 'G 'E]))
(SETQ PTVRG (STATUS 15))
(STATUS 18
PTVRG
(LAMBDA (%L %C %T)
(SETQ %L ['COMMENT])
(UNTIL (EQ (SETQ %C (READCH)) PTVRG)
(SETQ %L (CONS %C %L)))
(REVERSE %L)))
(OUTPUT (OR filout '(DSK (PRETTY . VLP) (GETPPN) \055)))
(%PC (PRIN1 (IF (BOUNDP 'VERSION) VERSION (VERSION))
(DATE) (TIME) 'FILE ': filin))
(PRETTYNIT)
(STATUS (IF (OR ?index (NOT ?sw1)) 1 2) 19)
(STATUS 2 18)
(INPUT filin)
; si on veut sauter le directory de ETV ;
; (AND (EQ (PEEKCH) (ASCII 59)) ;
; (READCH) ;
; (UNTIL (EQ (READCH) (ASCII 59)))) ;
(ESCAPE &EOF (WHILE T (TOPLEVEL))))
; 11 PRETTYF PRETTYSIZE PRETTYEND ;
(DF PRETTYF (filin)
; PRETTY-PRINT un fichier standard ;
; le 1er arg est le nom du fichier, le 2eme l'indic ;
; ex : (PRETTYF PRETTY) , (PRETTYF LODLAP T) ;
(PRETTYFILE ['DSK (CONS (CAR filin) 'VLP) (GETPPN) \055]
['DSK (CONS (CAR filin) 'VLI)]
(CADR filin)))))
(DE PRETTYSIZE (%N)
; initialise la largeur d'impression du PRETTY ;
(SETQ PRETTYSIZE (IF (NUMBP %N) %N 71)))
(DE PRETTYEND (;; X)
; recupere la place de PRETTY-PRINT ;
(SETQ X (STATUS 21))
(MAPC
'(%TAB ADDN FLATSIZE SARENTRE %EOL XPRDOT XSUIV %P1 %PP XPRTTY
XPRTTY1 XPRTTY2 SUPERP PRETTYP PRETTYFILE PRETTYSIZE PRETTYEND
CROSSPRINT CROSS CROSSFILE)
'(LAMBDA (X) (REMPROP X 'EXPR)))
(MAPC '(PRETTY PRETTYF CROSSF) (LAMBDA (X) (REMPROP X 'FEXPR)))
(AUTOLOAD PRETTY PRETTYP PRETTY PRETTYFILE PRETTYF PRETTYSIZE
PRETTYEND)
(PRINT 'PRETTYEND '= (DIFFER (STATUS 21) X)))
(OR (BOUNDP 'PRETTYSIZE) (SETQ PRETTYSIZE 71))
; 12 CROSSPRINT ;
(DE CROSSPRINT ( ;; #nb X)
; edite le resultat du CROSS ;
; les atomes references possedent sous l'indicateur ;
; 'CROSS la liste des numeros de lignes. ;
(SETQ ?index ())
(SETQ #nb 0)
(STATUS 2 20)
(PRINT "Cross Reference")
(TERPRI 2)
; impression de la liste des fonctions ;
(MAPC (SORTL (MAPCAR #nbfnt 'CAR))
(LAMBDA (L)
(MAPC
((LAMBDA (X) (COND ((NULL X) NIL)
((EQ (CAAR X) L) (CAR X))
(T (SELF (CDR X))) ))
#nbfnt)
'PRIN1)
(TERPRI)))
(TERPRI 2)
; edition du cross-ref ;
(MAPC (SORTL (MAPCT (OBLIST) (LAMBDA (L) (AND (GET L 'CROSS) L))))
(LAMBDA (L)
(SETQ X (GET L 'CROSS))
(REMPROP L 'CROSS)
(STATUS 7 0)
(TERPRI)
(PRIN1 (INCR #nb))
(TTAB 4) (PRIN1 L)
(STATUS 7 17) (TTAB 17)
(MAPC (FREVERSE X) (LAMBDA (X) (PRIN1 X)))
(TERPRI)))
(STATUS 7 0) (TERPRI))
; 13 CROSS CROSSFILE CROSSF ;
(DF CROSS (F ;; ?crossall ?index #nbline #nbfnt)
(SETQ #nbline 0)
(SETQ ?index T)
(SETQ ?crossall (CADR F))
(STATUS 7 9)
(EVAL ['PRETTY (CAR F)])
(CROSSPRINT)))
(DE CROSSFILE (filout filin ?crossall ;; ?index #nbline #nbfnt)
; CROSS-REF 'filin' dans 'filout' ;
; ?crossall = T si on veut tous les atomes systemes ;
(SETQ #nbline 0)
(SETQ ?index T)
(STATUS 7 9)
(SETQ PRETTYSIZE (PLUS PRETTYSIZE 10))
(OR filout (SETQ filout '(DSK (CROSS . VLC) (GETPPN) \055)))
(PRETTYFILE filout filin)
(SETQ PRETTYSIZE (DIFFER PRETTYSIZE 10))
filout))
(DF CROSSF (filin)
; CROSS-REF un fichier standard ;
; appel : (CROSSF nom de la file , valeur de ?crossall) ;
; ex : (CROSSF PRETTY ?crossall) ;
(CROSSFILE ['DSK (CONS (CAR filin) 'VLC) (GETPPN) \055]
['DSK (CONS (CAR filin) 'VLI)]
(CADR filin)))))
(POUR EVAL (MAPC (MAPCAR (MAKLIST "SYS:PRETTY.VLI loaded.
") 'CASCII) 'TYO))